home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / pp.em < prev    next >
Lisp/Scheme  |  1992-07-02  |  3KB  |  210 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117. (defmodule pp (standard0 ppl plural) ()
  118.  
  119.   (format t "\nThis module has no plural space conservation tweaks!\n")
  120.  
  121.   (setq global-field (make-paralation 512))    
  122.  
  123.   (setq base-context (car (contexts global-field)))
  124.   (setq base-offset  (car (contexts global-field)))
  125.  
  126.   (defun list-shift-distances (config)
  127.     (if (eq config 1) ()
  128.       (cons (/ config 2) (list-shift-distances (/ config 2)))))
  129.  
  130.   (setq shifts (mapcar (lambda (n) (car (offsets (elwise ((i global-field))
  131.                            (let ((get-from (+ i n)))
  132.                              (if (< get-from 512)
  133.                                (cons get-from ()) 
  134.                                ()))))))
  135.                (reverse (list-shift-distances 512))))
  136.  
  137.   (defun ll-vref (context offset shifter combiner)
  138.     (let ((shifter (mp-assign context (mp-make-plural base-context) shifter))
  139.       (ofst-p (mp-assign context (mp-make-plural base-context) offset))
  140.       (data (mp-make-plural context))
  141.       (tive (mp-make-plural context)))
  142.       (mp-move base-context ofst-p context shifter data)
  143.       (mp-move base-context (mp-assign context (mp-make-plural base-context)
  144.                        (mp-bang context t))
  145.            context shifter tive)
  146.       (mp-if context (mp-test context tive 2))
  147.       (mp-assign context tive (mp-car context tive))
  148.       (mp-if context tive)
  149. ;(format t "offset: ~a\n" (allocate-xec context offset))
  150. ;(format t "data (~a): ~a\n" data (allocate-xec context (mp-car context data)))
  151.       (mp-assign context offset (combiner offset (mp-car context data)))
  152. ;(format t "offset: ~a\n" (allocate-xec context offset))
  153.       (mp-fi context)
  154.       (mp-fi context)
  155.       offset))
  156.   
  157.   (defun l-vref (context offset combiner)
  158.     (let ((offset (mp-assign context (mp-make-plural context) offset)))
  159.       (labels ((recurse (shifts)
  160.          (ll-vref context offset (car shifts) combiner)
  161.          (if (null (cdr shifts)) offset
  162.            (recurse (cdr shifts)))))
  163.     (recurse shifts)
  164.     (mp-ref context offset 0))))
  165.  
  166.   (defun s-vref (l with)
  167.     (if (null (cdr l)) (car l)
  168.       (with (car l) (s-vref (cdr l) with))))
  169.  
  170.   (defmacro vref (f with)
  171.     `(s-vref (mapcar (lambda (c o) 
  172.                (Set-The-Context c)
  173.                (l-vref c o ,(rewire with)))
  174.              (contexts ,f) (offsets ,f)) ,with))
  175.   
  176.   (defun ll-scan (context offset combiner)
  177.     (let ((offset (mp-assign context (mp-make-plural context) offset)))
  178.       (labels ((recurse (shifts)
  179.          (ll-vref context offset (car shifts) combiner)
  180.          (if (null (cdr shifts)) offset
  181.            (recurse (cdr shifts)))))
  182.     (recurse shifts)
  183.     offset)))
  184.  
  185.   (defun l-scan (l with)
  186.     (if (null (cdr l)) l
  187.       (let ((rest (l-scan (cdr l) with)))
  188.     (cons (with (car l) (car rest)) rest))))
  189.  
  190.   (defmacro scan (f with)
  191.     `(let* ((result (make-field (paralation ,f) 
  192.                 (mapcar mp-make-plural (contexts ,f))))
  193.         (tmp-pspace (mp-ps-ref)))
  194.        (mapcar (lambda (c o r)
  195.          (Set-The-Context c)
  196.          (mp-assign c r (ll-scan c o ,(rewire with))))
  197.            (contexts ,f) (offsets ,f) (offsets result))
  198.        (mapcar (lambda (v c o)
  199.          (Set-The-Context c)
  200.          (mp-assign c o (,(rewire with) o (mp-bang c v))))
  201.            (cdr (l-scan (mapcar (lambda (c o) (mp-ref c o 0))
  202.                     (contexts ,f) (offsets result)) ,with))
  203.            (contexts ,f) (offsets result))
  204.        result))
  205.  
  206. (export scan vref s-vref l-vref ll-scan l-scan)
  207.  
  208. )
  209.  
  210.